#lang racket

(provide (all-defined-out))

(define compile-port
  (make-parameter
   (current-output-port)
   (lambda (p)
     (unless (output-port? p)
       (error 'compile-port (format "Not an output port ~s." p)))
     p)))

(define (emit . args)
  (apply fprintf (compile-port) args)
  (newline (compile-port)))

(define fxshift        2)
(define fxmask      #x03)
(define fxtag       #x00)
;(define bool-f      #x2F)
;(define bool-t      #x6F)
(define bool-f         0)
(define bool-t         1)
(define bool-bit       6)
(define boolmask    #xBF)
(define list-nil    #x3F)
(define eof-obj     #x7F)
(define charshift      8)
(define charmask    #x3F)
(define chartag     #x0F)
(define objshift       3)
(define objmask     #x07)
(define pairtag     #x01)
(define pairsize       8)
(define paircar        0)
(define paircdr        4)
(define vectortag   #x05)
(define stringtag   #x06)
(define closuretag  #x02)
(define symboltag   #x03)
(define wordsize       4) ; bytes
(define wordshift      2)
(define global-offset  4)
(define edi-offset     8)
(define return-addr #x17)


(define type-nil -1)
(define type-eof -2)
(define type-pair 256)
(define type-string 0)
(define type-symbol 1)
(define type-boolean 2)
(define type-integer 3)
(define type-fraction 4)
(define type-decimal 5)
(define type-character 6)
(define type-vector 7)
(define type-procedure 8)

(define enable-cps #t)
(define commetted  #f)

(define temp-registers
  '($ra $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7))

(define save-registers
  '($s0 $s1 $s2 $s3 $s4 $s5 $s6 $s7))

(define (emit-comment-start emitter)
  (if commetted (emit "#####  ~s: start  ######" emitter)
      '()))
(define (emit-comment-end emitter)
  (if commetted (emit "#####  ~s: end    ######" emitter)
      '()))

;(define (reg-name reg) (car reg))
;(define (reg-preserve? reg) (eq? 'preserve (cadr reg)))

(define fixnum-bits (- (* wordsize 8) fxshift))
(define fxlower (- (expt 2 (- fixnum-bits 1))))
(define fxupper (sub1 (expt 2 (- fixnum-bits 1))))
(define (fixnum? x)
  (and (integer? x) (exact? x) (<= fxlower x fxupper)))

(define (immediate? x)
  (or (fixnum? x) (boolean? x) (null? x) (char? x)))

(define (emit-immediate-nil)
  (emit "  li   $s1, -1")
  (emit "  li   $s2, 0")
  (emit "  li   $s3, 0"))

(define (emit-immediate-fixnum x)
  (emit "  li   $s1, 3")
  (emit "  li   $s2, ~s" x)
  (emit "  li   $s3, 1"))

(define (emit-immediate-boolean x)
  (emit "  li   $s1, 2")
  (emit "  li   $s2, ~s" (if x 1 0))
  (emit "  li   $s3, 0"))

(define (emit-immediate-char x)
  (emit "  li   $s1, 6")
  (emit "  li   $s2, ~s" (char->integer x))
  (emit "  li   $s3, 0"))

;(define (immediate-rep x)
;  (cond
;   [(fixnum? x) x]
;   [(boolean? x) (if x 1 0)]
;   [(null? x) list-nil]
;   [(char? x) (char->integer x)]
;   [else #f]))

;(define (emit-immediate x)
;  (emit "  mov $~s, %eax" (immediate-rep x)))
(define (emit-immediate x)
  (emit-comment-start 'emit-immediate)
  (cond
   [(fixnum? x) (emit-immediate-fixnum x)]
   [(boolean? x) (emit-immediate-boolean x)]
   [(null? x) (emit-immediate-nil)]
   [(char? x) (emit-immediate-char x)]
   [else #f])
  (emit-comment-end 'emit-immediate))

(define (tagged-list tag expr)
  (and (list? expr) (not (null? expr)) (eq? (car expr) tag)))


(define (make-begin lst) 
  (cond
   [(null? (cdr lst)) (car lst)]
   [else (cons 'begin lst)]))
(define (begin? expr)
  (and (tagged-list 'begin expr)
       (or (not (null? (begin-seq expr)))
           (error 'begin? (format "empty begin")))))

(define make-body make-begin)

(define begin-seq cdr)
(define (lambda? expr) (tagged-list 'lambda expr))
(define lambda-formals cadr)
(define (formals-to-vars formals)
  (cond
   [(list? formals) (map (lambda (x) (if (list? x) (car x) x)) formals)]
   [(pair? formals) (cons (car formals) (formals-to-vars (cdr formals)))]
   [else (list formals)]))
(define (lambda-vars expr)
  (formals-to-vars (lambda-formals expr)))
(define (map-formals f formals)
  (cond
   [(list? formals) (map (lambda (x) (if (pair? x) (cons (f (car x)) (cdr x)) (f x))) formals)]
   [(pair? formals) (cons (f (car formals)) (map-formals f (cdr formals)))]
   [else (f formals)]))
(define (lambda-body expr) (make-body (cddr expr)))
(define (make-lambda formals body)
  (list 'lambda formals body))

; (_ (prim-name arg* ...) b b* ...)
; (make-lambda '(arg* ...) (make-begin '(b b* ...)))

; (_ (prim-name . varargs) b b* ...)
; (make-lambda 'varargs (make-begin '(b b* ...)))

; (_ prim-name b)
; 'b

(define lib-primitives
  `(length
    ,(make-lambda '(lst)
                 (make-begin '((if (null? lst)
                                   0
                                   (fxadd1 (length (cdr lst)))))))
    fill
    ,(make-lambda '(args setop)
                 (make-begin '((letrec ([rec (lambda (index args)
                                               (unless (null? args)
                                                 (setop index (car args))
                                                 (rec (fxadd1 index) (cdr args))))])
                                 (rec 0 args)))))
    vector
    ,(make-lambda 'args
                 (make-begin '((let ([v (make-vector (length args))])
                                 (fill args (lambda (index arg) (vector-set! v index arg)))
                                 v))))
    string
    ,(make-lambda 'args
                 (make-begin '((let ([s (make-string (length args))])
                                 (fill args (lambda (index arg) (string-set! s index arg)))
                                 s))))
    list
    ,(make-lambda 'args
                 (make-begin '(args)))
    make_cell
    ,(make-lambda '(value)
                 (make-begin '((cons value '()))))
    cell_get
    ,(make-lambda '(cell)
                 (make-begin '((car cell))))
    cell_set
    ,(make-lambda '(cell value)
                 (make-begin '((set-car! cell value))))
    __symbols__
    ,'(make_cell '())
    string=?
    ,(make-lambda '(s1 s2)
                 (make-begin '((letrec ([rec (lambda (index)
                                               (or (fx= index (string-length s1))
                                                   (and (char= (string-ref s1 index) (string-ref s2 index))
                                                        (rec (fxadd1 index)))))])
                                 (and (string? s1) (string? s2) (fx= (string-length s1) (string-length s2)) (rec 0))))))
    __find_symbol__
    ,(make-lambda '(str)
                 (make-begin '((letrec ([rec (lambda (symbols)
                                               (cond
                                                 [(null? symbols) #f]
                                                 [(string=? str (string-symbol (car symbols))) (car symbols)]
                                                 [else (rec (cdr symbols))]))])
                                 (rec (cell_get __symbols__))))))
    string->symbol
    ,(make-lambda '(str)
                 (make-begin '((or (__find_symbol__ str)
                                   (let ([symbol (make-symbol str)])
                                     (cell_set __symbols__ (cons symbol (cell_get __symbols__)))
                                     symbol)))))
    error
    ,(make-lambda 'args
                 (make-begin '((foreign-call "ik_error" args))))
    log
    ,(make-lambda '(msg)
                 (make-begin '((foreign-call "ik_log" msg))))
    string-set!
    ,(make-lambda '(s i c)
                 (make-begin '((cond
                                 [(not (string? s)) (error)]
                                 [(not (fixnum? i)) (error)]
                                 [(not (char? c)) (error)]
                                 [(not (and (fx<= 0 i) (fx< i (string-length s)))) (error)]
                                 [else ($string-set! s i c)]))))
    string-ref
    ,(make-lambda '(s i)
                 (make-begin '((cond
                                 [(not (string? s)) (error)]
                                 [(not (fixnum? i)) (error)]
                                 [(not (and (fx<= 0 i) (fx< i (string-length s)))) (error)]
                                 [else ($string-ref s i)]))))
    vector-set!
    ,(make-lambda '(v i e)
                 (make-begin '((cond
                                 [(not (vector? v)) (error)]
                                 [(not (fixnum? i)) (error)]
                                 [(not (and (fx<= 0 i) (fx< i (vector-length v)))) (error)]
                                 [else ($vector-set! v i e)]))))
    vector-ref
    ,(make-lambda '(v i)
                 (make-begin '((cond
                                 [(not (vector? v)) (error)]
                                 [(not (fixnum? i)) (error)]
                                 [(not (and (fx<= 0 i) (fx< i (vector-length v)))) (error)]
                                 [else ($vector-ref v i)]))))
    liftneg
    ,(make-lambda '(f a b)
                 (make-begin '((cond
                                 [(and (fx< a 0) (fx>= b 0))
                                  (fx- 0 (f (fx- 0 a) b))]
                                 [(and (fx>= a 0) (fx< b 0))
                                  (fx- 0 (f a (fx- 0 b)))]
                                 [(and (fx< a 0) (fx< b 0))
                                  (f (fx- 0 a) (fx- 0 b))]
                                 [else
                                  (f a b)]))))
    liftneg1
    ,(make-lambda '(f a b)
                 (make-begin '((cond
                                 [(and (fx< a 0) (fx>= b 0))
                                  (fx- 0 (f (fx- 0 a) b))]
                                 [(and (fx>= a 0) (fx< b 0))
                                  (f a (fx- 0 b))]
                                 [(and (fx< a 0) (fx< b 0))
                                  (fx- 0 (f (fx- 0 a) (fx- 0 b)))]
                                 [else
                                  (f a b)]))))
    fxquotient
    ,(make-lambda '(a b)
                 (make-begin '((liftneg (lambda (a b) ($fxquotient a b)) a b))))
    fxremainder
    ,(make-lambda '(arg* ...)
                 (make-begin '((liftneg1 (lambda (a b) ($fxremainder a b)) a b))))
    exit
    ,(make-lambda 'args
                 (make-begin '((let ([status (if (null? args) 0 (car args))])
                                 (foreign-call "exit" status)))))
    s_write
    ,(make-lambda '(fd str len)
                 (make-begin '((foreign-call "s_write" fd str len))))
    stdout
    ,'(make-output-port "" 1)
    current-output-port
    ,(make-lambda '() (make-begin '(stdout)))
    BUFFER_SIZE
    4096
    open-output-file
    ,(make-lambda '(fname . args)
                 (make-begin '((let ([fd (foreign-call "s_open_write" fname)])
                                 (make-output-port fname fd)))))
    make-output-port
    ,(make-lambda '(fname fd)
                 (make-begin '((vector 'output-port fname fd (make-string BUFFER_SIZE) 0 BUFFER_SIZE))))
    output-port-fname
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 1))))
    output-port-fd
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 2))))
    output-port-buffer
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 3))))
    output-port-buffer-index
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 4))))
    output-port-buffer-size
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 5))))
    set-output-port-buffer-index!
    ,(make-lambda '(port index)
                 (make-begin '((vector-set! port 4 index))))
    inc-output-port-buffer-index!
    ,(make-lambda '(port)
                 (make-begin '((set-output-port-buffer-index! port (fxadd1 (output-port-buffer-index port))))))
    write-char
    ,(make-lambda '(c (port (current-output-port)))
                 (make-begin '((string-set! (output-port-buffer port) (output-port-buffer-index port) c)
                               (inc-output-port-buffer-index! port)
                               (when (fx= (output-port-buffer-index port) (output-port-buffer-size port))
                                 (output-port-write-buffer port)))))
    output-port?
    ,(make-lambda '(x)
                 (make-begin '((and (vector? x) (fx= (vector-length x) 6) (eq? 'output-port (vector-ref x 0))))))
    output-port-write-buffer
    ,(make-lambda '(port)
                 (make-begin '((s_write (output-port-fd port)
                                        (output-port-buffer port)
                                        (output-port-buffer-index port))
                               (set-output-port-buffer-index! port 0))))
    flush-output-port
    ,(make-lambda '((port (current-output-port)))
                 (make-begin '((output-port-write-buffer port)
                               (foreign-call "s_fflush" (output-port-fd port)))))
    close-output-port
    ,(make-lambda '(port)
                 (make-begin '((flush-output-port port)
                               (unless (string=? "" (output-port-fname port))
                                 (foreign-call "s_close" (output-port-fd port))))))
    write
    ,(make-lambda '(x (port (current-output-port)))
                 (make-begin '((flush-output-port port)
                               ;; This is cheating... should write it in Scheme.
                               (foreign-call "scheme_write" (output-port-fd port) x 0)
                               (flush-output-port port))))
    display
    ,(make-lambda '(x (port (current-output-port)))
                 (make-begin '((flush-output-port port)
                               (foreign-call "scheme_write" (output-port-fd port) x 2)
                               (flush-output-port port))))
    open-input-file
    ,(make-lambda '(fname . args)
                 (make-begin '((let ([fd (foreign-call "s_open_read" fname)])
                                 (make-input-port fname fd)))))
    make-input-port
    ,(make-lambda '(fname fd)
                 (make-begin '((vector 'input-port fname fd))))
    input-port-fname
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 1))))
    input-port-fd
    ,(make-lambda '(port)
                 (make-begin '((vector-ref port 2))))
    input-port?
    ,(make-lambda '(x)
                 (make-begin '((and (vector? x) (fx= (vector-length x) 3) (eq? 'input-port (vector-ref x 0))))))
    read-char
    ,(make-lambda '(port)
                 (make-begin '((foreign-call "s_read_char" (input-port-fd port)))))
    close-input-port
    ,(make-lambda '(port)
                 (make-begin '((foreign-call "s_close" (input-port-fd port)))))))

(define (is-prim? x lst)
  (cond
    ((null? lst) #f)
    ((eq? x (car lst)) #t)
    (else (is-prim? x (cddr lst)))))

(define (is-lib-prim? x lst) (is-prim? x lst))

(define (primitive? x)
  (and (symbol? x) (is-prim? x primitives)))

(define (lib-primitive? x)
  (and (symbol? x) (is-lib-prim? x lib-primitives)))

(define (code x lst)
  (cond
    ((null? lst) #f)
    ((eq? x (car lst)) (cadr lst))
    (else (code x (cddr lst)))))


(define (lib-primitive-code x)
  (or (code x lib-primitives) (error 'lib-primitive-code (format "primitive ~s has no lib code" x))))

(define (primitive-emitter x)
  (or (code x primitives) (error 'primitive-emitter (format "primitive ~s has no emitter" x))))

(define aexpr-primitives '(constant-ref primitive-ref))

(define (aexpr-primcall? expr)
  (and (pair? expr) (primitive? (car expr)) (member (car expr) aexpr-primitives)))

(define (primcall? expr)
  (and (pair? expr) (primitive? (car expr))))

;(define (check-primcall-args prim args)
;  ((if (getprop prim '*vararg*) <= =) (getprop prim '*arg-count*) (length args)))

(define (emit-any-primcall si env prim args)
  ;  (or (check-primcall-args prim args)
  ;      (error 'emit-primcall (format "incorrect number of arguments to ~s" prim)))
  (emit-comment-start 'emit-any-primcall)
  (apply (primitive-emitter prim) si env args)
  (emit-comment-end 'emit-any-primcall))

(define (emit-aexpr-primcall si env expr)
  (let ([prim (car expr)]
        [args (cdr expr)])
    (emit-comment-start 'emit-aexpr-primcall)
    (emit-any-primcall si env prim args)
    (emit-comment-end 'emit-aexpr-primcall)))

(define (emit-primcall si env expr)
  (let ([prim (car expr)]
	[cont (cadr expr)]
	[args (cddr expr)])
    (emit-comment-start 'emit-primcall)
    (emit-any-primcall si env prim args)
    (emit-stack-save si)
    (emit-expr (next-stack-index si) env cont)
    (emit "  move  $s0, $a0      # $s0 = $a0      ")
    (emit-stack-load si)
    (emit-stack-save (- wordsize))
    (emit "  move  $a0, $s0      # $a0 = $s0      ")
    (emit-load-closure-label)
    (emit "  move  $s7, $a0      # $s1 = $a0      ")
    (emit "  li    $a0, 1        # $a0 = 1        ")
    (emit "  jr    $s7           # return         ")
    (emit-comment-end 'emit-primcall)))

(define unique-label
  (let ([count 0])
    (lambda ()
      (let ([L (string->symbol (format "L_~s" count))])
        (set! count (add1 count))
        L))))

(define (emit-stack-save si)
  (emit "  sw   $a0, ~s($sp)" si))

(define (emit-stack-load si)
  (emit "  lw   $a0, ~s($sp)" si))

(define (next-stack-index si)
  (- si wordsize))

; (_ (prim-name si env arg* ...) b b* ...)
; (lambda (si env arg* ...) b b* ...)

; (_ (prim-name si env arg* ... . vararg) b b* ...)
; (lambda (si env arg* ... . vararg) b b* ...)


(define (emit-cmp-type type)
  (emit "  move  $a0, $s1               ")
  (emit "  li    $t0, ~s                " type)
  (emit-cmp-bool))

(define (emit-cmp-type-and-value type value)
  (emit "  move  $t1, $s1               ")
  (emit "  move  $t2, $s2               ")
  (emit "  move  $a0, $t1               ")
  (emit "  li    $t0, ~s                " type)
  (emit-cmp-bool)
  (emit "  move  $t1, $s2               ")
  (emit "  move  $a0, $t2               ")
  (emit "  li    $t0, ~s                " value)
  (emit-cmp-bool)
  (emit "  move  $t2, $s2               ")
  (emit "  and   $s2, $t1, $t2          "))

(define (emit-cmp-bool . args)
  (let ((label1 (unique-label))
        (label2 (unique-label)))
    (emit-comment-start 'emit-cmp-bool)
    (emit "  ~s    $a0, $t0, ~s  # if $a0 == ?    " (if (null? args) 'beq (car args)) label1)
    (emit "  li    $v0, ~s       # $v0 = 0        " bool-f)
    (emit "  j     ~s            #                " label2)
    (emit "~s:                                    " label1)
    (emit "  li    $v0, ~s       # $v0 = 1        " bool-t)
    (emit "~s:                                    " label2)
    (emit "  li    $s1, 2        #                ")
    (emit "  move  $s2, $v0      #                ")
    (emit "  li    $s3, 0        #                ")
    (emit-comment-end 'emit-cmp-bool)))

(define (emit-binop si env arg1 arg2)
  (emit-comment-start 'emit-binop)
  (emit-expr si env arg1)
  (emit "  move  $t1, $s2      # $t1 = $s2      ")
  (emit-expr si env arg2)
  (emit "  move  $t2, $s2      # $t2 = $s2      ")
  (emit-comment-end 'emit-binop))

(define (emit-cmp-binop setx si env arg1 arg2)
  (emit-comment-start 'emit-cmp-binop)
  (emit-binop si env arg1 arg2)
  (emit "  move  $a0, $t1      # $a0 = $t1      ")
  (emit "  move  $t0, $t2      # $t0 = $t2      ")
  (emit-cmp-bool setx)
  (emit-comment-end 'emit-cmp-binop))

; (define (primitive-label name) name)  ;todo

(define (primitive-label name)
  (let ([lst (map (lambda (c)
		    (case c
		      [(#\-) #\_]
		      [(#\!) #\b]
		      [(#\=) #\e]
		      [(#\>) #\g]
		      [(#\?) #\p]
		      [else c]))
		  (string->list (symbol->string name)))])
  (string->symbol (format "P_~a" (list->string lst)))))

;(define (emit-make-string si)
;  (emit-comment-start 'emit-make-string)
;  (emit "  shr $~s, %eax" fxshift)
;  (emit "  add $~s, %eax" wordsize)
;  (emit-heap-alloc-dynamic (next-stack-index si))
;  (emit-stack-to-heap si 0)
;  (emit "  or $~s, %eax" stringtag)
;  (emit-comment-end 'emit-make-string))

;(define (emit-make-vector si)
;  (emit "  add $~s, %eax" wordsize)
;  (emit-heap-alloc-dynamic (next-stack-index si))
;  (emit-stack-to-heap si 0)
;  (emit "  or $~s, %eax" vectortag))



#|
# s-expression storage:
# 1. nil
#           -1       |    0      |    0
# 2. pair
#           0x0100   |    car    |    cdr
# 3. atom
# 3.1 string
#           0x0000   | str addr  | str length
# 3.2 symbol
#           0x0001   | sym addr  | sym length
# 3.3 boolean
#           0x0002   | bool val  | 
# 3.4 integer
#           0x0003   | int  val  | 1
# 3.5 fraction
#           0x0004   | numer val | denom val 
# 3.6 decimal
#           0x0005   | double val| double val 
# 3.7 character
#           0x0006   | int  val  | 
# 3.8 vector
#           0x0007   | vec addr  | vec length
|#

(define (mock-nil-p)
  (emit-immediate-nil))

; todo
(define (mock-pair-p car-data cdr-data)
  (emit "  li   $s1, 256")
  (emit "  la   $s2, ~s" car-data)
  (emit "  la   $s3, ~s" cdr-data))

; todo
(define (mock-string-p str)
  (emit "  li   $s1, 0")
  (emit "  li   $s2, ~s" str)
  (emit "  li   $s3, ~s" (string-length str)))

; todo
(define (mock-symbol-p sym)
  (emit "  li   $s1, 1")
  (emit "  li   $s2, ~s" sym)
  (emit "  li   $s3, ~s" (string-length sym)))

(define (mock-true-p)
  (emit-immediate-boolean #t))

(define (mock-false-p)
  (emit-immediate-boolean #f))

(define (mock-fixnum-p num)
  (emit-immediate-fixnum num))


(define (mock-char-p c)
  (emit-immediate-char c))






(define primitives
  `(fxadd1
    ,(lambda (si env arg)
       (emit-comment-start 'fxadd1)
       (emit-expr si env arg)
       (emit "  add   $s2, $s2, 1   # fxadd1 ")
       (emit-comment-end 'fxadd1))
    fxsub1
    ,(lambda (si env arg)
       (emit-comment-start 'fxsub1)
       (emit-expr si env arg)
       (emit "  add   $s2, $s2, -1  # fxsub1 ")
       (emit-comment-end 'fxsub1))
    fixnum->char
    ,(lambda (si env arg)
       (emit-comment-start 'fixnum->char)
       (emit-expr si env arg)
       (emit "  li    $s1, 6  # fixnum->char ")
       (emit "  li    $s3, 0                 ")
       (emit-comment-end 'fixnum->char))
    char->fixnum
    ,(lambda (si env arg)
       (emit-comment-start 'char->fixnum)
       (emit-expr si env arg)
       (emit "  li    $s1, 3  # char->fixnum ")
       (emit "  li    $s3, 1                 ")
       (emit-comment-end 'char->fixnum))
    fixnum?
    ,(lambda (si env arg)
       (emit-comment-start 'fixnum?)
       (emit-expr si env arg)
       (emit-cmp-type type-integer)
       (emit-comment-end 'fixnum?))
    fxzero?
    ,(lambda (si env arg)
       (emit-comment-start 'fxzero?)
       (emit-expr si env arg)
       (emit-cmp-type-and-value type-integer 0)
       (emit-comment-end 'fxzero?))
    null?
    ,(lambda (si env arg)
       (emit-comment-start 'null?)
       (emit-expr si env arg)
       (emit-cmp-type type-nil)
       (emit-comment-end 'null?))
    eof-object?
    ,(lambda (si env arg)
       (emit-comment-start 'eof-object?)
       (emit-expr si env arg)
       (emit-cmp-type type-eof)
       (emit-comment-end 'eof-object?))
    eof-object
    ,(lambda (si env)
       (emit-comment-start 'eof-object)
       (emit "  li    $s1, -2 # eof          ")
       (emit "  li    $s2, 0                 ")
       (emit "  li    $s3, 0                 ")
       (emit-comment-end 'eof-object))
    boolean?
    ,(lambda (si env arg)
       (emit-comment-start 'boolean?)
       (emit-expr si env arg)
       (emit-cmp-type type-boolean)
       (emit-comment-end 'boolean?))
    char?
    ,(lambda (si env arg)
       (emit-comment-start 'char?)
       (emit-expr si env arg)
       (emit-cmp-type type-character)
       (emit-comment-end 'char?))
    not
    ,(lambda (si env arg)
       (emit-comment-start 'not)
       (emit-expr si env arg)
       (emit-cmp-type-and-value type-boolean 0)
       (emit-comment-end 'not))
    fxlognot
    ,(lambda (si env arg)
      (emit-comment-start 'fxlognot)
      (emit-expr si env arg)
      (emit "  not   $s2, $s2                ")
      (emit-comment-end 'fxlognot))
    fx+
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx+)
      (emit-binop si env arg1 arg2)
      (emit "  add   $s2, $t1, $t2 # $s2 = $t1 + $t2")
      (emit-comment-end 'fx+))
    fx-
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx-)
      (emit-binop si env arg1 arg2)
      (emit "  sub   $s2, $t1, $t2 # $s2 = $t1 - $t2")
      (emit-comment-end 'fx-))
    fx*
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx*)
      (emit-binop si env arg1 arg2)
      (emit "  mul   $s2, $t1, $t2 # $s2 = $t1 * $t2")
      (emit-comment-end 'fx*))
    $fxquotient
    ,(lambda (si env arg1 arg2)
       (emit-comment-start '$fxquotient)
       (emit-binop si env arg1 arg2)
       (emit "  div   $t1, $t2")
       (emit "  mfhi  $s2")
       (emit-comment-end '$fxquotient))
    $fxremainder
    ,(lambda (si env arg1 arg2)
       (emit-comment-start '$fxremainder)
       (emit "  div   $t1, $t2")
       (emit "  mflo  $s2")
       (emit-comment-end '$fxremainder))
    fxlogor
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fxlogor)
      (emit-binop si env arg1 arg2)
      (emit "  or    $s2, $t1, $t2 # $a0 = $t1 | $t2")
      (emit-comment-end 'fxlogor))
    fxlogand
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fxlogand)
      (emit-binop si env arg1 arg2)
      (emit "  and   $s2, $t1, $t2 # $a0 = $t1 & $t2")
      (emit-comment-end 'fxlogand))
    fx=
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx=)
      (emit-binop si env arg1 arg2)
      (emit-cmp-binop 'beq si env arg1 arg2)
      (emit-comment-end 'fx=))
    fx<
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx<)
      (emit-binop si env arg1 arg2)
      (emit-cmp-binop 'blt si env arg1 arg2)
      (emit-comment-end 'fx<))
    fx<=
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx<=)
      (emit-binop si env arg1 arg2)
      (emit-cmp-binop 'ble si env arg1 arg2)
      (emit-comment-end 'fx<=))
    fx>
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx>)
      (emit-binop si env arg1 arg2)
      (emit-cmp-binop 'bgt si env arg1 arg2)
      (emit-comment-end 'fx>))
    fx>=
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'fx>=)
      (emit-binop si env arg1 arg2)
      (emit-cmp-binop 'bge si env arg1 arg2)
      (emit-comment-end 'fx>=))
    constant-ref
    ,(lambda (si env constant)
      (emit-comment-start 'constant-ref)
      (emit "  lw    $a0, ~s       # $a0 = ?       " constant)
      (emit-comment-end 'constant-ref))
    constant-init
    ,(lambda (si env constant value)
      (emit-comment-start 'constant-init)
      (emit ".data  ~s    .word 0       # $a0 = ?  " constant)
      (emit-expr si env value)
      (emit "  sw    $a0, ~s       # $a0 = ?       " constant)
      (emit-comment-end 'constant-init))
    primitive-ref
    ,(lambda (si env prim-name)
      (let ([label (primitive-label prim-name)]
            [done-label (unique-label)])
        (emit-comment-start 'primitive-ref)
        (emit "  lw    $a0, ~s       # $a0 = ?       " label)
        (emit-comment-end 'primitive-ref)))
    foreign-call
    ,(lambda (si env name . args)
       (let ([new-si (let loop ([si (+ si wordsize)]
                                [args (reverse args)])
                       (cond
                         [(null? args) si]
                         [else
                          (emit-expr-save (next-stack-index si) env (car args))
                          (loop (next-stack-index si) (cdr args))]))])
         (emit-comment-start 'foreign-call)
         (emit-adjust-base new-si)
         (emit-call name)
         (emit-adjust-base (- new-si))
         (emit-comment-end 'foreign-call)))
    make-symbol
    ,(lambda (si env str)
       (emit-comment-start 'make-symbol)
       (emit-expr si env str)
       (emit "  li    $s1, ~s       # $s1 = ?        " type-string)
       (emit-comment-end 'make-symbol))
    string-symbol
    ,(lambda (si env symbol)
       (emit-comment-start 'string-symbol)
       (emit-expr si env symbol)
       (emit "  li    $s1, ~s       # $s1 = ?        " type-symbol)
       (emit-comment-end 'string-symbol))
    symbol?
    ,(lambda (si env arg)
       (emit-comment-start 'symbol?)
       (emit-expr si env arg)
       (emit-cmp-type type-symbol)
       (emit-comment-end 'symbol?))
    make-string
    ,(lambda (si env length)
       (emit-comment-start 'make-string)
       (emit-expr-save si env length)
       ;(emit "  shr $~s, %eax" fxshift)
       ;(emit "  add $~s, %eax" wordsize)
       (emit-heap-alloc-dynamic (next-stack-index si))
       (emit-stack-to-heap si 0)
       ;(emit "  or $~s, %eax" stringtag)
       (emit "  li  $s1, ~s" type-string)
       (emit-comment-end 'make-string))
    string?
    ,(lambda (si env arg)
       (emit-comment-start 'string?)
       (emit-expr si env arg)
       (emit-cmp-type type-string)
       (emit-comment-end 'string?))
    $string-set!
    ,(lambda (si env string index value)
       (emit-comment-start '$string-set!)
       ;       (emit-expr si env index)
       ;       (emit "  shr $~s, %eax" fxshift)
       ;       (emit "  add $~s, %eax" wordsize)
       ;       (emit-stack-save si)
       ;       (emit-expr (next-stack-index si) env value)
       ;       (emit "  shr $~s, %eax" charshift)
       ;       (emit-stack-save (next-stack-index si))
       ;       (emit-expr (next-stack-index (next-stack-index si)) env string)
       ;       (emit "  add ~s(%esp), %eax" si)
       ;       (emit "  mov ~s(%esp), %edx" (next-stack-index si))
       ;       (emit "  movb %dl, ~s(%eax)" (- stringtag))
       ;       (emit "  mov $0, %eax")
       (emit-expr si env index)
       (emit "  move  $t0, $s1")
       (emit-expr (next-stack-index si) env value)
       (emit "  move  $t1, $s1")
       (emit-expr (next-stack-index (next-stack-index si)) env string)
       (emit "  move  $t2, $s1")
       (emit "  add   $t3, $t2, $t0")
       (emit "  sb    $t1, 0($t3)")
       (emit-comment-end '$string-set!))
    $string-ref
    ,(lambda (si env string index)
       (emit-comment-start '$string-ref)
       ;      (emit-expr si env index)
       ;      (emit "  shr $~s, %eax" fxshift)
       ;      (emit "  add $~s, %eax" wordsize)
       ;      (emit-stack-save si)
       ;      (emit-expr (next-stack-index si) env string)
       ;      (emit "  add ~s(%esp), %eax" si)
       ;      (emit "  movzb ~s(%eax), %eax" (- stringtag))
       ;      (emit "  shl $~s, %eax" charshift)
       ;      (emit "  or $~s, %eax" chartag)
       (emit-expr si env index)
       (emit "  move  $t0, $s1")
       (emit-expr (next-stack-index si) env string)
       (emit "  move  $t1, $s1")
       (emit "  add   $t2, $t1, $t0")
       (emit "  li    $s1, ~s" type-character)
       (emit "  lbu   $s2, 0($t2)")
       (emit-comment-end '$string-ref))
    string-length
    ,(lambda (si env arg)
       (emit-comment-start 'string-length)
       (emit-expr si env arg)
       ;(emit-heap-load (- stringtag))
       (emit "  li    $s1, ~s" type-integer)
       (emit "  move  $s2, $s3")
       (emit "  li    $s3, 1")
       (emit-comment-end 'string-length))
    char=
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'char=)
      (emit-cmp-binop 'beq si env arg1 arg2)
      (emit-comment-end 'char=))
    make-vector
    ,(lambda (si env length)
       (emit-comment-start 'make-vector)
       (emit-expr-save si env length)
       ;(emit "  add $~s, %eax" wordsize)
       (emit-heap-alloc-dynamic (next-stack-index si))
       (emit-stack-to-heap si 0)
       ;(emit "  or $~s, %eax" vectortag)
       (emit "  li  $s1, ~s" type-vector)
       (emit-comment-end 'make-vector))
    vector?
    ,(lambda (si env arg)
       (emit-comment-start 'vector?)
       (emit-expr si env arg)
       (emit-cmp-type type-vector)
       (emit-comment-end 'vector?))
    vector-length
    ,(lambda (si env arg)
       (emit-comment-start 'vector-length)
       (emit-expr si env arg)
       ;(emit-heap-load (- vectortag))
       (emit "  li    $s1, ~s" type-vector)
       (emit "  move  $s2, $s3")
       (emit "  li    $s3, 1")
       (emit-comment-end 'vector-length))
    $vector-set!
    ,(lambda (si env vector index value)
       (emit-comment-start '$vector-set!)
       ;       (emit-expr si env index)
       ;       (emit "  add $~s, %eax" wordsize)
       ;       (emit-stack-save si)
       ;       (emit-expr-save (next-stack-index si) env value)
       ;       (emit-expr (next-stack-index (next-stack-index si)) env vector)
       ;       (emit "  add ~s(%esp), %eax" si)
       ;       (emit-stack-to-heap (next-stack-index si) (- vectortag))
       ;       (emit "  mov $0, %eax")

       (emit-expr si env index)
       (emit "  move  $t0, $s1")
       (emit-expr (next-stack-index si) env value)
       (emit "  move  $t1, $s1")
       (emit-expr (next-stack-index (next-stack-index si)) env string)
       (emit "  move  $t2, $s1")
       (emit "  add   $t3, $t2, $t0")
       ;(emit "  sb    $t1, 0($t3)")
       (emit-stack-to-heap (next-stack-index si) type-vector)
       (emit-comment-end '$vector-set!))
    $vector-ref
    ,(lambda (si env vector index)
       ;       (emit-comment-start '$vector-ref)
       ;       (emit-expr si env index)
       ;       (emit "  add $~s, %eax" wordsize)
       ;       (emit-stack-save si)
       ;       (emit-expr (next-stack-index si) env vector)
       ;       (emit "  add ~s(%esp), %eax" si)
       ;       (emit-heap-load (- vectortag))

       (emit-expr si env index)
       (emit "  move  $t0, $s1")
       (emit-expr (next-stack-index si) env string)
       (emit "  move  $t1, $s1")
       (emit "  add   $t2, $t1, $t0")
       (emit-heap-load type-vector)
       (emit-comment-end '$vector-ref))
    procedure?
    ,(lambda (si env arg)
       (emit-comment-start 'procedure?)
       (emit-expr si env arg)
       (emit-cmp-type type-procedure)
       (emit-comment-end 'procedure?))
    cons
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'cons)
      (emit-binop si env arg1 arg2)
      (emit-stack-save (next-stack-index si))
      (emit-cons si (next-stack-index (next-stack-index si)))
      (emit-comment-end 'cons))
    pair?
    ,(lambda (si env arg)
       (emit-comment-start 'pair?)
       (emit-expr si env arg)
       (emit-cmp-type type-pair)
       (emit-comment-end 'pair?))
    car
    ,(lambda (si env arg)
      (emit-comment-start 'car)
      (emit-expr si env arg)
      (emit-heap-load (- paircar pairtag)) ; lw 4
      (emit-comment-end 'car))
    cdr
    ,(lambda (si env arg)
      (emit-comment-start 'cdr)
      (emit-expr si env arg)
      (emit-heap-load (- paircdr pairtag)) ; lw 8
      (emit-comment-end 'cdr))
    set-car!
    ,(lambda (si env cell val)
      (emit-comment-start 'set-car!)
      (emit-binop si env val cell)
      (emit-stack-to-heap si (- paircar pairtag))
      ;(emit "  mov $0, %eax")
      (emit-comment-end 'set-car!))
    set-cdr!
    ,(lambda (si env cell val)
      (emit-comment-start 'set-cdr!)
      (emit-binop si env val cell)
      (emit-stack-to-heap si (- paircdr pairtag))
      ;(emit "  mov $0, %eax")
      (emit-comment-end 'set-cdr!))
    eq?
    ,(lambda (si env arg1 arg2)
      (emit-comment-start 'eq?)
      (emit-binop si env arg1 arg2)
      ;(emit "  cmp ~s(%esp), %eax" si) ;todo
      (emit-cmp-bool)
      (emit-comment-end 'eq?))
    mock-nil
    ,(lambda (si env)
      (mock-nil-p))
    mock-true
    ,(lambda (si env)
      (mock-true-p))
    mock-false
    ,(lambda (si env)
      (mock-false-p))
    mock-fixnum
    ,(lambda (si env arg)
      (mock-fixnum-p arg))
    mock-char
    ,(lambda (si env arg)
      (mock-char-p arg))))


;(define (primitive? x)
;  (and (symbol? x) (getprop x '*is-prim*)))
;(define (primitive-emitter x)
;  (or (getprop x '*emitter*) (error 'primitive-emitter (format "primitive ~s has no emitter" x))))
;
;(define (lib-primitive? x)
;  (and (symbol? x) (getprop x '*is-lib-prim*)))
;(define (lib-primitive-code x)
;  (or (getprop x '*lib-code*) (error 'lib-primitive-code (format "primitive ~s has no lib code" x))))


; (_ (prim-name si env arg* ...) b b* ...)
; (lambda (si env arg* ...) b b* ...)

; (_ (prim-name si env arg* ... . vararg) b b* ...)
; (lambda (si env arg* ... . vararg) b b* ...)


(define (if? expr)
  (and (tagged-list 'if expr)
       (or (= 3 (length (cdr expr)))
           (error 'if? (format "malformed if ~s" expr)))))
(define if-test cadr)
(define if-conseq caddr)
(define if-altern cadddr)


(define (emit-if si env tail expr)
  (let ([alt-label (unique-label)]
        [end-label (unique-label)])
    (emit-comment-start 'if)
    (emit-expr si env (if-test expr))

    (emit "  xori  $t0, $s1, ~s" type-boolean)
    (emit "  xori  $t1, $s2, ~s" bool-f)
    (emit "  or    $t2, $t0, $t1")
    (emit "  beq   $t2, $zero, ~s" alt-label)
    
    ;(emit "  li  $t2, ~s" bool-f)
    ;(emit "  beq $s2, $t2, ~a" alt-label)
    (emit-any-expr si env tail (if-conseq expr))
    (if (not tail) (emit "  j  ~a" end-label) '())
    (emit-label alt-label)
    (emit-any-expr si env tail (if-altern expr))
    (emit-label end-label)
    (emit-comment-end 'if)))

(define variable? symbol?)

(define (emit-begin si env tail expr)
  (emit-seq si env tail (begin-seq expr)))
(define (emit-seq si env tail seq)
  (cond
   [(null? seq) (error 'emit-seq "empty seq")]
   [(null? (rest seq)) (emit-any-expr si env tail (first seq))]
   [else
    (emit-expr si env (first seq))
    (emit-seq si env tail (rest seq))]))

(define (make-set! lhs rhs)
  (list 'set! lhs rhs))
(define (set? expr)
  (tagged-list 'set! expr))
(define set-lhs cadr)
(define set-rhs caddr)
(define make-let list)
(define (let-form? let-kind expr)
  (and (tagged-list let-kind expr)
       (or (not (null? (cddr expr)))
           (error 'let-form? (format "let without body ~s" expr)))))
(define let-kind car)
(define (any-let? expr)
  (and (pair? expr)
       (member (let-kind expr) '(let let* letrec))
       (let-form? (let-kind expr) expr)))
(define (let? expr) (let-form? 'let expr))
(define (let*? expr) (let-form? 'let* expr))
(define (letrec? expr) (or (let-form? 'letrec expr) (let-form? 'letrec* expr)))
(define let-bindings cadr)
(define letrec-bindings let-bindings)
(define labels-bindings let-bindings)

(define let-body-seq cddr)
(define (let-body expr)
  (make-body (let-body-seq expr)))
(define letrec-body let-body)
(define labels-body let-body)
(define empty? null?)
(define (bind lhs rhs)
  (check-variable lhs)
  (list lhs rhs))
(define first car)
(define rest cdr)
(define rhs cadr)
(define (lhs binding)
  (check-variable (car binding)))
(define (check-variable var)
  (if (variable? var)
      var
      (error 'lhs (format "~s is not a variable" var))))
(define (make-initial-env bindings)
  bindings)
(define (bulk-extend-env vars vals env)
  (append (map list vars vals) env))
(define (extend-env var si env)
  (cons (list var si) env))
(define (lookup var env)
  (cond
   [(assv var env) => cadr]
   [else #f]))

(define (emit-let si env tail expr)
  (define (process-let bindings si new-env)
    (cond
     [(empty? bindings)
      (emit-any-expr si new-env tail (let-body expr))]
     [else
      (let ([b (first bindings)])
        (emit-expr si env (rhs b))
        (emit-stack-save si)
        (process-let (rest bindings)
           (next-stack-index si)
           (extend-env (lhs b) si new-env)))]))
  (process-let (let-bindings expr) si env))

(define (extend-env-with si env lvars k)
  (if (null? lvars)
      (k si env)
      (extend-env-with
       (next-stack-index si)
       (extend-env (first lvars) si env)
       (rest lvars)
       k)))

(define (free-var offset)
  (list 'free (- offset closuretag)))
(define (free-var? fv)
  (tagged-list 'free fv))
(define free-var-offset cadr)

(define (close-env-with offset env lvars k)
  (if (null? lvars)
      (k env)
      (close-env-with
       (+ offset wordsize)
       (extend-env (first lvars) (free-var offset) env)
       (rest lvars)
       k)))

(define (emit-variable-ref si env var)
  (cond
   [(lookup var env) =>
    (lambda (v)
      (cond 
       [(free-var? v)
        (emit "  sw   $t1, ~s($sp)  #mov ?(%edi), %eax" (free-var-offset v))] ;sw   $t1, 4($sp)
       [(number? v)
        (emit-stack-load v)]
       [else (error 'emit-variable-ref (format "looked up unknown value ~s for var ~s" v var))]))]
   [else (error 'emit-variable-ref (format "undefined variable ~s" var))]))

(define (emit-ret-if tail)
  (if tail (emit "  jr $ra") '()))


(define (assert a)
  (if a a '()))

(define (emit-expr si env expr)
  (emit-any-expr si env #f expr))

(define (emit-tail-expr si env expr)
  (emit-any-expr si env #t expr))

(define (emit-any-expr si env tail expr)
  (cond
   [(immediate? expr)           (emit-immediate expr)             (emit-ret-if tail)]
   [(variable? expr)            (emit-variable-ref si env expr)   (emit-ret-if tail)]
   [(closure? expr)             (emit-closure si env expr)        (emit-ret-if tail)]
   [(if? expr)                  (emit-if si env tail expr)        (assert (or (not enable-cps) tail))]
   [(let? expr)                 (emit-let si env tail expr)       (assert (or (not enable-cps) tail))]
   [(begin? expr)               (emit-begin si env tail expr)     (assert (not enable-cps))]
   [(or (aexpr-primcall? expr)
        (and (not enable-cps)
             (primcall? expr))) (emit-aexpr-primcall si env expr) (emit-ret-if tail)]
   [(and enable-cps
         (primcall? expr))      (emit-primcall si env expr)       (assert      tail)]
   [(app? expr)                 (emit-app si env tail expr)       (assert  (or (not enable-cps) tail))]
   [else (error 'emit-expr (format "~s is not an expression" expr))]))

(define unique-name
  (let ([counts '()])
    (lambda (name)
      (cond
       [(assv name counts) =>
        (lambda (p)
          (let* ([count (cdr p)]
                 [new-name (string->symbol (format "~s_~s" name count))])
            ;(set-mcdr! p (add1 count))
            (set! p (cons (car p) (add1 count)))
            new-name))]
       [(lib-primitive? name)
        (set! counts (cons (cons name 1) counts))
	(unique-name name)]
       [else
        (set! counts (cons (cons name 1) counts))
        name]))))

#|
-------------------------------------------------------------------------------------
.data
var1: .word 23 # declare storage for var1; 
#initial value is 23

.text
__start:
lw $t0, var1 # load contents of RAM location
# into register $t0:  
# $t0 = var1

li $t1, 5 # $t1 = 5   ("load immediate")
sw $t1, var1 # store contents of register $t1 
# into RAM:  var1 = $t1 done
done



-------------------------------------------------------------------------------------
|#


(define (define? expr)
  (tagged-list 'define expr))
;; TODO: support syntatic (define (f ...) ...) form.
(define (define-lhs expr)
  (cadr expr))
(define (define-rhs expr)
  (make-body (cddr expr)))
(define (macro-expand expr)
  (define (transform expr bound-vars)
    (cond
     [(and (begin? expr) (not (null? (filter define? (begin-seq expr)))))
      (let loop ([prev '()] [defs '()] [todo (begin-seq expr)])
	(cond
	 [(define? (car todo))
	  (loop prev
		(append defs (list (bind (define-lhs (car todo)) (define-rhs (car todo)))))
		(cdr todo))]
	 [(null? defs)
	  (loop (append prev (list (car todo)))
		defs
		(cdr todo))]
	 [else
	  (let ([last (make-let
		       'letrec
		       defs
		       (make-body todo))])
	    (transform
	     (if (null? prev)
		 last
		 (combine-exprs (make-begin prev) last))
	     bound-vars))]))]
     [(set? expr)
      (make-set! (set-lhs expr) (transform (set-rhs expr) bound-vars))]
     [(lambda? expr)
      (let* ([formals (lambda-formals expr)]
	     [optional-args (filter list? (if (list? formals) formals '()))])
	(if (null? optional-args)
	    (make-lambda
	     formals
	     (transform (lambda-body expr)
			(append (lambda-vars expr) bound-vars)))
	    (let ([new-formals (map (lambda (x)
				      (if (list? x)
					  (list (car x))
					  x))
				    formals)]
		  [bindings (map (lambda (var-val)
				   (let ([var (car var-val)]
					 [val (cadr var-val)])
				     (bind var
					   `(if ,var ,var ,val))))
				 optional-args)])
	      (make-lambda
	       new-formals
	       (transform
		(make-let
		 'let*
		 bindings
		 (lambda-body expr))
		(append (lambda-vars expr) bound-vars))))))]
     [(let? expr)
      (make-let
       (let-kind expr)
       (map (lambda (binding)
              (bind (lhs binding) (transform (rhs binding) bound-vars)))
            (let-bindings expr))
       (transform (let-body expr)
                  (append (map lhs (let-bindings expr)) bound-vars)))]
     [(let*? expr)
      (transform
       (if (null? (let-bindings expr))
           (let-body expr)
           (make-let
            'let
            (list (first (let-bindings expr)))
            (make-let
             'let*
             (rest (let-bindings expr))
             (let-body expr))))
       bound-vars)]
     [(letrec? expr)
      (transform
       (make-let
        'let
        (map (lambda (binding) (bind (lhs binding) '#f))
             (letrec-bindings expr))
        (make-body
         (append
          (map (lambda (binding) (make-set! (lhs binding) (rhs binding)))
               (letrec-bindings expr))
          (let-body-seq expr))))
       bound-vars)]
     [(tagged-list 'and expr)
      (cond
       [(null? (cdr expr)) #t]
       [(null? (cddr expr)) (transform (cadr expr) bound-vars)]
       [else
        (transform
         `(if ,(cadr expr)
              (and ,@(cddr expr))
              #f)
         bound-vars)])]
     [(tagged-list 'or expr)
      (cond
       [(null? (cdr expr)) #f]
       [(null? (cddr expr)) (transform (cadr expr) bound-vars)]
       [else
        (transform
         `(let ([one ,(cadr expr)]
                [thunk (lambda () (or ,@(cddr expr)))])
            (if one
                one
                (thunk)))
         bound-vars)])]
     [(tagged-list 'when expr)
      (transform
       `(if ,(cadr expr)
            ,(make-begin (cddr expr))
            #f)
       bound-vars)]
     [(tagged-list 'unless expr)
      (transform
       `(when (not ,(cadr expr)) ,@(cddr expr))
       bound-vars)]
     [(tagged-list 'cond expr)
      (transform
       (let* ([conditions (cdr expr)]
              [first-condition (car conditions)]
              [first-test (car first-condition)]
              [first-body (cdr first-condition)]
              [rest (if (null? (cdr conditions)) #f `(cond ,@(cdr conditions)))])
         (cond
          [(and (eq? first-test 'else) (not (member 'else bound-vars)))
           (make-begin first-body)]
          [(null? first-body)
           `(or ,first-test ,rest)]
          [(and (eq? '=> (car first-body)) (not (member '=> bound-vars)))
           `(let ([one ,first-test])
              (if one (,(cadr first-body) one) ,rest))]
          [else
           `(if ,first-test ,(make-begin first-body) ,rest)]))
       bound-vars)]
     [(list? expr) (map (lambda (e) (transform e bound-vars)) expr)]
     [else expr]))
  (transform expr '()))
      
(define (alpha-conversion expr)
  (define (transform expr env)
    (cond
     [(variable? expr)
      (or (lookup expr env)
          (and (lib-primitive? expr) expr)
          (error 'alpha-conversion (format "undefined variable ~s" expr)))]
     [(lambda? expr)
      (let ([new-env (bulk-extend-env
                      (lambda-vars expr)
                      (map unique-name (lambda-vars expr))
                      env)])
        (make-lambda
         (map-formals (lambda (v) (lookup v new-env)) (lambda-formals expr))
         (transform (lambda-body expr) new-env)))]
     [(let? expr)
      (let* ([lvars (map lhs (let-bindings expr))]
            [new-env (bulk-extend-env
                      lvars
                      (map unique-name lvars)
                      env)])
        (make-let
         'let
         (map (lambda (binding)
                (bind (lookup (lhs binding) new-env)
                      (transform (rhs binding) env)))
              (let-bindings expr))
         (transform (let-body expr) new-env)))]
     [(quote? expr) expr]
     [(and (list? expr) (not (null? expr)) (special? (car expr)))
      (cons (car expr) (map (lambda (e) (transform e env)) (cdr expr)))]
     [(list? expr) (map (lambda (e) (transform e env)) expr)]
     [else expr]))
  (transform expr (make-initial-env '())))

(define (assignment-conversion expr)
  (let ([assigned '()])
    (define (set-variable-assigned! v)
      (unless (member v assigned)
              (set! assigned (cons v assigned))))
    (define (variable-assigned v)
      (member v assigned))
    (define (mark expr)
      (when (set? expr) (set-variable-assigned! (set-lhs expr)))
      (when (list? expr) (for-each mark expr)))
    (define (transform expr)
      (cond
       [(set? expr) 
        `(set-car! ,(set-lhs expr) ,(transform (set-rhs expr)))]
       [(lambda? expr)
        (let ([vars (filter variable-assigned (lambda-vars expr))])
          (make-lambda
           (lambda-formals expr)
           (if (null? vars)
               (transform (lambda-body expr))
               (make-let
                'let
                (map (lambda (v) (bind v `(cons ,v #f))) vars)
                (transform (lambda-body expr))))))]
       [(let? expr)
        (make-let
         'let
         (map (lambda (binding)
                (let ([var (lhs binding)]
                      [val (transform (rhs binding))])
                  (bind var
                        (if (variable-assigned var)
                            `(cons ,val #f)
                            val))))
              (let-bindings expr))
         (transform (let-body expr)))]
       [(list? expr) (map transform expr)]
       [(and (variable? expr) (variable-assigned expr))
        `(car ,expr)]
       [else expr]))
    (mark expr)
    (transform expr)))

(define (quote? expr)
  (tagged-list 'quote expr))
(define quote-expr cadr)

(define (translate-quote expr)
  (cond
   [(immediate? expr) expr]
   [(symbol? expr) (list 'string->symbol (translate-quote (symbol->string expr)))]
   [(pair? expr)
    (list 'cons (translate-quote (car expr)) (translate-quote (cdr expr)))]
   [(vector? expr)
    (cons 'vector (map translate-quote (vector->list expr)))]
   [(string? expr)
    (cons 'string (map translate-quote (string->list expr)))]
   [else (error 'translate-quote (format "don't know how to quote ~s" expr))]))

(define (lift-constants expr)
  (let ([constants '()])
    (define (transform expr)
      (cond
       [(and (quote? expr) (immediate? (quote-expr expr))) (quote-expr expr)]
       [(and (quote? expr) (assoc expr constants)) => cadr]
       [(quote? expr)
        (set! constants (cons (list expr (list 'constant-ref (unique-name 'c))) constants))
        (cadr (assoc expr constants))]
       [(string? expr) (transform `(quote ,expr))]
       [(foreign-call? expr) (make-foreign-call (foreign-call-name expr) (map transform (foreign-call-args expr)))]
       [(list? expr) (map transform expr)]
       [else expr]))
    (let ([texpr (transform expr)])
      (make-let
       'labels
       (map (lambda (val-cst)
              (bind (cadadr val-cst) '(datum)))
            constants)
       (if (null? constants)
           texpr
           (combine-exprs
            (make-begin
             (map (lambda (val-cst)
                    (list 'constant-init
                          (cadadr val-cst)
                          (all-expr-conversions (translate-quote (quote-expr (car val-cst))))))
                  constants))
            texpr))))))
(define (combine-exprs a b)
  (cond
   [(and (begin? a) (begin? b)) (make-begin (append (begin-seq a) (begin-seq b)))]
   [(begin? a) (make-begin (append (begin-seq a) (list b)))]
   [(begin? b) (make-begin (cons a (begin-seq b)))]
   [else (make-begin (list a b))]))


(define (annotate-lib-primitives expr)
  (define (transform expr)
    (cond
     [(and (variable? expr) (lib-primitive? expr)) `(primitive-ref ,expr)]
     [(list? expr) (map transform expr)]
     [else expr]))
  (transform expr))

;(define (primitive-label name)
;  (let ([lst (map (lambda (c)
;		    (case c
;		      [(#\-) #\_]
;		      [(#\!) #\b]
;		      [(#\=) #\e]
;		      [(#\>) #\g]
;		      [(#\?) #\p]
;		      [else c]))
;		  (string->list (symbol->string name)))])
;  (string->symbol (format "P_~a" (list->string lst)))))

(define (primitive-alloc name)
  (string->symbol (format "~a_alloc" (primitive-label name))))

;; Not used, as let can avoid useless closure creation.
(define (macro-expand-let expr)
  (define (transform expr)
    (cond
     [(let? expr)
      (let ([vars (map lhs (let-bindings expr))]
	    [vals (map (lambda (binding) (transform (rhs binding)))
		       (let-bindings expr))])
	(cons (make-lambda
	       vars
	       (transform (let-body expr)))
	      vals))]
     [(list? expr) (map (lambda (e) (transform e)) expr)]
     [else expr]))
  (transform expr))

(define (cps-conversion expr)
  (make-let
   'labels
   (let-bindings expr)
   (cps-top (let-body expr))))


(define (cps-top expr)
  (T-k expr (lambda (x) x)))

(define (aexpr? expr)
  (or (lambda? expr)
      (immediate? expr)
      (symbol? expr)
      (string? expr)
      (aexpr-primcall? expr)))

(define (T-k expr k)
  (cond
   [(aexpr? expr)
    (k (M expr))]
   [(begin? expr)
    (let ([expr (first (begin-seq expr))]
	  [exprs (rest (begin-seq expr))])
      (if (null? exprs)
	  (T-k expr k)
	  (T-k expr (lambda (_)
		      (T-k `(begin ,@exprs) k)))))]
   [(if? expr)
    (let* ([exprc (if-test expr)]
	   [exprt (if-conseq expr)]
	   [exprf (if-altern expr)]
	   [$rv (unique-name '$rv)]
	   [cont `(lambda (,$rv) ,(k $rv))])
      (T-k exprc (lambda (aexp)
		   `(if ,aexp
			,(T-c exprt cont)
			,(T-c exprf cont)))))]
   [(let? expr)
    (let ([vars (map lhs (let-bindings expr))]
	  [vals (map rhs (let-bindings expr))])
      (T*-k vals (lambda ($vals)
		   (make-let
		    'let
		    (map bind vars $vals)
		    (T-k (let-body expr) k)))))]
   [(app? expr)
    (let* ([$rv (unique-name '$rv)]
	   [cont `(lambda (,$rv) ,(k $rv))])
      (T-c expr cont))]
   [else (error 'T-k (format "~s is not an expression" expr))]))


(define (T-c expr c)
  (cond
   [(aexpr? expr)
    `(,c ,(M expr))]
   [(begin? expr)
    (let ([expr (first (begin-seq expr))]
	  [exprs (rest (begin-seq expr))])
      (if (null? exprs)
	  (T-c expr c)
	  (T-k expr (lambda (_)
		      (T-c `(begin ,@exprs) c)))))]
   [(if? expr)
    (let ([exprc (if-test expr)]
	  [exprt (if-conseq expr)]
	  [exprf (if-altern expr)]
	  [$k (unique-name '$k)])
      `((lambda (,$k)
	  ,(T-k exprc (lambda (aexp)
			`(if ,aexp
			     ,(T-c exprt $k)
			     ,(T-c exprf $k)))))
	,c))]
   [(let? expr)
    (let ([vars (map lhs (let-bindings expr))]
	  [vals (map rhs (let-bindings expr))])
      (T*-k vals (lambda ($vals)
		   (make-let
		    'let
		    (map bind vars $vals)
		    (T-c (let-body expr) c)))))]
   [(app? expr)
    (let ([f (call-target expr)]
	  [es (call-args expr)])
      (T-k f (lambda ($f)
	       (T*-k es (lambda ($es)
			  (let ([app `(,$f ,c ,@$es)])
			    (if (call-apply? expr)
				(cons 'apply app)
				app)))))))]
   [else (error 'T-c (format "~s is not an expression" expr))]))

(define (T*-k exprs k)
  (cond
   [(null? exprs)
    (k '())]
   [(pair? exprs)
    (T-k (car exprs) (lambda (hd)
      (T*-k (cdr exprs) (lambda (tl)
        (k (cons hd tl))))))]))

(define (M aexpr)
  (cond
   [(lambda? aexpr)
    (let ([$k (unique-name '$k)])
      `(lambda ,(cons $k (lambda-formals aexpr))
	 ,(T-c (lambda-body aexpr) $k)))]
   [(eq? 'call/cc aexpr)
    '(lambda (cc f) (f cc (lambda (_ x) (cc x))))]
   [else aexpr]))



(define (closure-conversion expr)
  (let ([labels '()]
        [constants (map lhs (labels-bindings expr))])
    (define (transform expr . label)
      (cond
       [(lambda? expr)
        (let ([label (or (and (not (null? label)) (car label)) (unique-label))]
              [fvs (filter (lambda (v) (not (member v constants))) (free-vars expr))]
	      [body (transform (lambda-body expr))])
          (set! labels
                (cons (bind label
                            (make-code (lambda-formals expr)
                                       fvs
                                       body))
                    labels))
          (make-closure label fvs))]
       [(any-let? expr)
        (make-let (let-kind expr)
                  (map (lambda (binding)
                         (bind (lhs binding) (transform (rhs binding))))
                       (let-bindings expr))
                  (transform (let-body expr)))]
       [(list? expr)
        (map transform expr)]
       [else
        expr]))
    (let* ([body (transform (labels-body expr))])
      (make-let 'labels labels body))))

(define (all-expr-conversions expr)
  (annotate-lib-primitives (assignment-conversion (alpha-conversion (macro-expand expr)))))
(define (all-conversions expr)
  (closure-conversion ((if enable-cps cps-conversion (lambda (x) x)) (lift-constants (all-expr-conversions expr)))))

(define (special? symbol)
  (or (member symbol '(if begin let lambda closure set! quote apply))
      (and enable-cps (eq? symbol 'call/cc))
      (primitive? symbol)))

(define (flatmap f . lst)
  (apply append (apply map f lst)))

(define (free-vars_ expr)
  (cond
   [(variable? expr) (list expr)]
   [(lambda? expr) (filter (lambda (v) (not (member v (lambda-vars expr))))
                           (free-vars_ (lambda-body expr)))]
   [(let? expr)
    (append
     (flatmap free-vars_ (map rhs (let-bindings expr)))
     (filter (lambda (v) (not (member v (map lhs (let-bindings expr)))))
             (free-vars_ (let-body expr))))]
   [(tagged-list 'primitive-ref expr) '()]
   [(list? expr) (flatmap free-vars_ (if (and (not (null? expr)) (special? (car expr))) (cdr expr) expr))]
   [else '()]))

(define (remove-dups xs)
  (if (null? xs)
      xs
      (cons (first xs)
	    (remove-dups (filter (lambda (el) (not (equal? (first xs) el))) xs)))))

(define (free-vars expr)
  (remove-dups (free-vars_ expr)))

(define (emit-library)
  (define (emit-library-primitive prim-name)
    (let ([labels (all-conversions (lib-primitive-code prim-name))])
      (emit-labels labels (lambda (expr env)
        ((emit-code env #t) (make-code '() '() expr) (primitive-alloc prim-name))))
      (let ([label (primitive-label prim-name)])
        ;(emit ".global ~s" label)
        ;(emit ".comm ~s,4,4" label)
        (emit "~s: .word  0" label))))
  (define (iterate libs)
    (if (null? libs) '()
        (begin (emit-library-primitive (car libs))
               (iterate (cddr libs)))))
  (iterate lib-primitives))

(define (emit-labels expr k)
  (let* ([bindings (labels-bindings expr)]
         [labels (map lhs bindings)]
         [codes (map rhs bindings)]
         [env (make-initial-env '())])
    (for-each (emit-code env #f) codes labels)
    (k (labels-body expr) env)))

(define (make-closure label fvs)
  (cons 'closure (cons label fvs)))
(define (closure? expr) (tagged-list 'closure expr))
(define closure-label cadr)
(define closure-free-vars cddr)
(define (emit-closure si env expr)
  (let ([label (closure-label expr)]
        [fvs (closure-free-vars expr)])
    (emit-comment-start 'closure)
    (emit-heap-alloc-static si (* (+ 2 (length fvs)) wordsize))
    (emit "  li   $t0, ~s  # movl ?, (%eax)" (length fvs))  ;(immediate-rep (length fvs))
    (emit "  sw   $t0, ($a0)")
    ;(emit "  movl $~s, ~s(%eax)" label wordsize)
    (emit "  la   $t0, ~s " label)
    (emit "  sw   $t0, ~s($a0)" wordsize)

    ; todo
    ;    (unless (null? fvs)
    ;      (emit "  mov %eax, %edx")
    ;      (let loop ([fvs fvs] [count 2])
    ;	(unless (null? fvs)
    ;          (emit-variable-ref si env (first fvs))
    ;	  (emit "  mov %eax, ~s(%edx)" (* count wordsize))
    ;	  (loop (rest fvs) (add1 count))))
    ;      (emit "  mov %edx, %eax"))
    ;(emit "  or $~s, %eax" closuretag)
    (emit-comment-end 'closure)))

(define (emit-load-closure-label)
  ; (emit-heap-load (- wordsize closuretag))
  (emit-heap-load wordsize))





(define (make-code formals free body)
  (list 'code formals free body))
(define code-formals cadr)
(define (code-bound-variables expr) (formals-to-vars (code-formals expr)))
(define (code-vararg? expr)
  (not (list? (code-formals expr))))
(define (code-optarg? expr)
  (and (list? (code-formals expr)) (not (null? (filter list? (code-formals expr))))))
(define (code-opt-start-index expr)
  (let loop ([index 0] [formals (code-formals expr)])
    (if (list? (car formals))
	index
	(loop (add1 index) (cdr formals)))))
(define code-free-variables caddr)
(define code-body cadddr)
(define (emit-code env global?)
  (lambda (expr label)
    ((if global? emit-function-header emit-label) label)
    (let ([bvs (code-bound-variables expr)]
          [fvs (code-free-variables expr)]
          [body (code-body expr)])
      (emit-comment-start 'emit-code)
      (when (and (not (code-vararg? expr)) (not (code-optarg? expr)))
	    (let ([start-label (unique-label)])
              (emit "  #emit-code not code-vararg? code-optarg?")
              ;       (emit "  li  $t0, ~s  " (length bvs))
              ;	      (emit "  beq $a0, $t0, ~a" start-label)
              ;	      (emit-error (- wordsize) env)
              ;	      (emit-label start-label)
              ;	      (emit "  li  $a0, ~s  " (length bvs))
              ))
      (when (code-optarg? expr)
	    (let ([start-index (code-opt-start-index expr)]
		  [len (length bvs)]
		  [check2-label (unique-label)]
		  [loop-label (unique-label)]
		  [start-label (unique-label)])
              (emit "  #emit-code code-optarg?")
              ;	      (emit "  mov %eax, %edx")
              ;	      (emit "  cmp $~s, %edx" start-index)
              ;	      (emit "  jge ~a" check2-label)
              ;	      (emit-error (- wordsize) env)
              ;	      (emit-label check2-label)
              ;	      (emit "  cmp $~s, %edx" len)
              ;	      (emit "  jle ~a" loop-label)
              ;	      (emit-error (- wordsize) env)
              ;	      (emit-label loop-label)
              ;	      (emit "  cmp $~s, %edx" len)
              ;	      (emit "  je ~a" start-label)
              ;	      (emit "  add $1, %edx")
              ;	      (emit "  mov %edx, %eax")
              ;	      (emit "  shl $~s, %eax" wordshift)
              ;	      (emit "  neg %eax")
              ;	      (emit "  add %esp, %eax")
              ;	      (emit "  movl $~s, (%eax)" bool-f)
              ;	      (emit-jmp loop-label)
              ;	      (emit-label start-label)
              ;	      (emit "  mov %edx, %eax")
              ))
      (when (code-vararg? expr)
            (let ([ok (unique-label)]
		  [start-label (unique-label)]
                  [fill-label (unique-label)]
                  [loop-label (unique-label)])
              (emit "  #emit-code code-vararg?")
              ;              (emit "  mov %eax, %edx")
              ;	      (when (> (- (length bvs) 1) 0)
              ;		    (emit "  cmp $~s, %edx" (- (length bvs) 1))
              ;		    (emit "  jge ~a" ok)
              ;		    (emit-error (- wordsize) env)
              ;		    (emit-label ok))
              ;              (emit-immediate '())
              ;              (emit "  cmp $~s, %edx" (- (length bvs) 1))
              ;              (emit "  je ~a" fill-label)
              ;              (emit-label loop-label)
              ;              (emit "  cmp $~s, %edx" (length bvs))
              ;              (emit "  jl ~a" start-label)
              ;              (emit "  shl $~s, %edx" wordshift)
              ;              (emit "  sub %edx, %esp")
              ;              (emit-stack-save (next-stack-index 0))
              ;              (emit "  mov %edx, %eax")
              ;              (emit-stack-save (next-stack-index (next-stack-index 0)))
              ;              (emit-cons 0 (next-stack-index (next-stack-index (next-stack-index 0))))
              ;              (emit-stack-save 0)
              ;              (emit-stack-load (next-stack-index (next-stack-index 0)))
              ;              (emit "  mov %eax, %edx")
              ;              (emit-stack-load 0)
              ;              (emit "  add %edx, %esp")
              ;              (emit "  shr $~s, %edx" wordshift)
              ;              (emit "  sub $1, %edx")
              ;              (emit-jmp loop-label)
              ;              (emit-label fill-label)
              ;              (emit "  add $1, %edx")
              ;              (emit "  shl $~s, %edx" wordshift)
              ;              (emit "  sub %edx, %esp")
              ;              (emit-stack-save 0)
              ;              (emit "  add %edx, %esp")
              ;              (emit-label start-label)
              ))
      ;      (extend-env-with (- wordsize) env bvs (lambda (si env)
      ;        (close-env-with (* 2 wordsize) env fvs (lambda (env)
      ;          (emit-tail-expr si env body)))))

      (emit "  jr  $ra")
      (emit-comment-end 'emit-code))))
(define (app? expr)
  (and (list? expr) (not (null? expr))))
(define (call-apply? expr)
  (tagged-list 'apply expr))
(define (call-target expr) 
  (if (call-apply? expr)
      (cadr expr)
      (car expr)))
(define (call-args expr)
  (if (call-apply? expr)
      (cddr expr)
      (cdr expr)))
(define (emit-app si env tail expr)
  (define (emit-arguments si args)
    (unless (empty? args)
      (emit-expr si env (first args))
      (emit-stack-save si)
      (emit-arguments (- si wordsize) (rest args))))
  (define (move-arguments si delta args)
    (unless (or (= delta 0) (empty? args))
      (emit-stack-load si)
      (emit-stack-save (+ si delta))
      (move-arguments (- si wordsize) delta (rest args))))
  (define (splice-last-argument)
    (let ([si (- (* wordsize (length (call-args expr))))]
	  [loop-label (unique-label)]
	  [pair-label (unique-label)]
	  [done-label (unique-label)])
      (emit "  #emit-app splice-last-argument")
      
      ;      (emit-stack-save (next-stack-index si))
      ;      (emit "  mov $~s, %eax" (length (call-args expr)))
      ;      (emit-stack-save (next-stack-index (next-stack-index si)))
      ;      (emit "  mov %eax, %edx")
      ;      (emit-stack-load si)
      ;      (emit-label loop-label)
      ;      (emit "  cmp $~s, %al" list-nil)
      ;      (emit "  jne ~a" pair-label)
      ;      (emit "  mov %edx, %eax")
      ;      (emit "  shl $2, %eax")
      ;      (emit "  neg %eax")
      ;      (emit "  add %esp, %eax")
      ;      (emit "  mov -4(%eax), %edx")
      ;      (emit "  mov -8(%eax), %eax")
      ;      (emit "  sub $1, %eax")
      ;      (emit-jmp done-label)
      ;      (emit-label pair-label)
      ;      (emit "  mov %edx, %eax")
      ;      (emit "  shl $2, %eax")
      ;      (emit "  neg %eax")
      ;      (emit "  add %esp, %eax")
      ;      (emit "  mov -8(%eax), %edx")
      ;      (emit "  add $1, %edx")
      ;      (emit "  mov %edx, -12(%eax)")
      ;      (emit "  mov -4(%eax), %edx")
      ;      (emit "  mov %edx, -8(%eax)")
      ;      (emit "  mov (%eax), %edx")
      ;      (emit "  mov ~s(%edx), %edx" (- paircdr pairtag))
      ;      (emit "  mov %edx, -4(%eax)")
      ;      (emit "  mov (%eax), %edx")
      ;      (emit "  mov ~s(%edx), %edx" (- paircar pairtag))
      ;      (emit "  mov %edx, (%eax)")
      ;      (emit "  mov %eax, %edx")
      ;      (emit "  mov -4(%eax), %eax")
      ;      (emit "  mov -12(%edx), %edx")
      ;      (emit-jmp loop-label)
      ;      (emit-label done-label)
      ))
  (emit-comment-start 'emit-app)
  (cond
   [(not tail)
    (emit "  #emit-app not-tail")
    ;    (emit "  mov %edi, ~s(%esp)" si)
    ;    (emit "  movl $~s, ~s(%esp)" return-addr (next-stack-index si))
    ;    (emit-arguments (- si (* 3 wordsize)) (call-args expr))
    ;    (emit-expr (- si (* wordsize (+ 3 (length (call-args expr))))) env (call-target expr))
    ;    (emit "  mov %eax, %edi")
    ;    (emit-ensure-procedure si env expr)
    ;    (emit-load-closure-label)
    ;    (emit-adjust-base (next-stack-index si))
    ;    (emit "  mov %eax, %edx")
    ;    (if (call-apply? expr)
    ;	(begin
    ;	  (emit "  sub $4, %esp")
    ;	  (splice-last-argument)
    ;	  (emit "  add $4, %esp"))
    ;	(emit "  mov $~s, %eax" (length (call-args expr))))
    ;    (emit-call "*%edx")
    ;    (emit-adjust-base (- (next-stack-index si)))
    ;    (emit "  mov ~s(%esp), %edi" si)
    ]
   [else ; tail
    (emit "  #emit-app tail")
    ;    (emit-expr (- si (* wordsize (length (call-args expr)))) env (call-target expr))
    ;    (emit "  move $s0, $a0  # mov %eax, %edi")
    ;    (emit-ensure-procedure si env expr)
    ;    (move-arguments si (- (+ si wordsize)) (call-args expr))
    ;    (emit "  move $a0, $s0  # mov %edi, %eax")
    ;    (emit-load-closure-label)
    ;    (emit "  move $t5, $a0  # mov %eax, %edx")
    ;    (if (call-apply? expr)
    ;	(splice-last-argument)
    ;	(emit "  li $a0, ~s # mov ?, %eax" (length (call-args expr))))
    ;    ;(emit-jmp "*%edx")
    ;    (emit "  jalr $t5 ")

    (emit-arguments si (call-args expr))
    (move-arguments si (- (+ si wordsize)) (call-args expr))
    ;(emit-jmp (lookup (call-target expr) env))
    (if (pair? (call-target expr))
        (emit-jmp (cadr (call-target expr)))
        '())
    ])
  (emit-comment-end 'emit-app))
(define (emit-ensure-procedure si env expr)
  (unless (equal? (call-target expr) '(primitive-ref error))
    (let ([ok (unique-label)])
      (emit-comment-start 'emit-ensure-procedure)
      ;(emit "  and $~s, %al" objmask)
      ;(emit "  cmp $~s, %al" closuretag)
      ;(emit "  je ~a" ok)
      (emit "  move  $a0, $s1               ")
      (emit "  li    $t0, ~s                " type-procedure)
      (emit "  beq   $a0, $t0, ~a" ok)
      (emit-error si env)
      (emit-label ok)
      ;(emit "  mov %edi, %eax")
      (emit-comment-end 'emit-ensure-procedure))))
(define (emit-error si env)
  (emit-tail-expr si env (if enable-cps '((primitive-ref error) #f) '((primitive-ref error)))))

(define (foreign-call? expr)
  (tagged-list 'foreign-call expr))
(define (make-foreign-call name args)
  (cons 'foreign-call (cons name args)))
(define foreign-call-name cadr)
(define foreign-call-args cddr)


;(define heap-cell-size (arithmetic-shift 1 objshift))
(define heap-cell-size 12)
(define (emit-heap-alloc-static si size)
  (let ([alloc-size (* (add1 (/ (sub1 size) heap-cell-size)) heap-cell-size)])
    (emit-comment-start 'emit-heap-alloc-static)
    ;(emit "  mov $~s, %eax" alloc-size)
    ;(emit-heap-alloc si)
    (emit "  li   $a0, ~s" alloc-size)
    (emit "  li   $v0, 9")
    (emit "  syscall")
    (emit "  move $a0, $v0")
    (emit-comment-end 'emit-heap-alloc-static)))
(define (emit-heap-alloc-dynamic si)
  (emit-comment-start 'emit-heap-alloc-dynamic)
  ;  (emit "  add $~s, %eax" (sub1 heap-cell-size))
  ;  (emit "  and $~s, %eax" (- heap-cell-size))
  ;  (emit-heap-alloc si)
  (emit "  li   $a0, ~s" heap-cell-size)
  (emit "  li   $v0, 9")
  (emit "  syscall")
  (emit "  move $a0, $v0")
  (emit-comment-end 'emit-heap-alloc-dynamic))
;(define (emit-heap-alloc si)
;  (let ([new-si (- si (* 2 wordsize))])
;    (emit-comment-start 'emit-heap-alloc)
;    (emit-adjust-base new-si)
;    (emit "  mov %eax, ~s(%esp)" (* 2 wordsize))
;    (emit "  mov %esp, %eax")
;    (emit "  add $~s, %eax"      (* 2 wordsize))
;    (emit "  mov %eax, ~s(%esp)" (* 1 wordsize))
;    (emit "  mov %ebp, ~s(%esp)" (* 0 wordsize))
;    (emit "  mov %edi, ~s(%ebp)" edi-offset)
;    (emit-call "heap_alloc")
;    (emit-adjust-base (- new-si))
;    (emit "  mov ~s(%ebp), %edi" edi-offset)
;    (emit-comment-end 'emit-heap-alloc)))
(define (emit-stack-to-heap si offset)
  (emit-comment-start 'emit-stack-to-heap)
  ;  (emit "  mov ~s(%esp), %edx" si)
  ;  (emit "  mov %edx, ~s(%eax)" offset)
  (emit "  lw  $t0, ~s($a0) #mov ?(%esp), %edx" si)
  (emit "  sw  $t0, ~s($a0) #mov %edx, ?(%eax)" offset)
  (emit-comment-end 'emit-stack-to-heap))
(define (emit-heap-load offset)
  (emit-comment-start 'emit-heap-load)
  (emit "  lw  $a0, ~s($a0) # mov ?(%eax), %eax" offset)
  (emit-comment-end 'emit-heap-load))

;(define (emit-object? tag si env arg)
;  (emit-comment-start 'emit-object?)
;  (emit-expr si env arg)
;  (emit "  and $~s, %al" objmask)
;  (emit "  cmp $~s, %al" tag)
;  (emit-cmp-bool)
;  (emit-comment-end 'emit-object?))


(define (emit-expr-save si env arg)
  (emit-expr si env arg)
  (emit-stack-save si))

(define (emit-cons si free-si)
  (emit-comment-start 'emit-cons)
  (emit-heap-alloc-static free-si pairsize)
  ;(emit "  or $~s, %eax" pairtag)
  (emit "  li    $s1, ~s                " type-pair)
  (emit-stack-to-heap si (- paircar pairtag))
  (emit-stack-to-heap (next-stack-index si) (- paircdr pairtag))
  (emit-comment-end 'emit-cons))


(define (emit-label label)
  (emit "~a:" label))

(define (emit-function-header f)
  (emit "  .text")
  (emit "  .globl ~a" f)
  (emit-label f))

(define (emit-scheme-entry expr env)
  (emit-function-header "L_scheme_entry")
  (emit-tail-expr (- wordsize) env expr))

;(define (emit-adjust-base si)
;  (cond
;   [(> si 0) (emit "  add $~s, %esp" si)]
;   [(< si 0) (emit "  sub $~s, %esp" (- si))]))

(define (emit-adjust-base si)
  (cond
   [(> si 0) (emit "  #add $~s, %esp" si)]
   [(< si 0) (emit "  #sub $~s, %esp" (- si))]))

(define (emit-call label)
  (emit "  jal ~a" label))

(define (emit-jmp label)
  (emit "  j   ~a" label))

(define (preserve-registers cmd)
  (let loop ([regs temp-registers] [count 0])
    (unless (null? regs)
      (let ([reg (first regs)])
        (if (member reg temp-registers)
          (cmd reg (* count wordsize))
          '())
        (loop (rest regs) (+ count 1))))))

(define (backup-registers)
  (preserve-registers
   (lambda (name num)
     (emit "  sw ~a, ~s($sp)" name num))))

(define (restore-registers)
  (preserve-registers
   (lambda (name num)
     (emit "  lw ~a, ~s($sp)" name num))))

(define (emit-which-library label)
  (emit "  .text")
  (emit "  .globl ~a" label)
  (emit-label label)
  (emit "  jr  $ra"))
    
(define (emit-program expr)
  (emit-which-library "error")
  (emit-function-header "main")
  (emit "  addi $sp, $sp, -36")
  (backup-registers)
  ;(emit "  mov %ecx, %esi")
  ;(emit "  mov 12(%esp), %ebp")
  ;(emit "  mov 8(%esp), %esp")
  ;(emit "  mov $0, %edi")
  (emit-call "L_scheme_entry")
  ;(emit "  mov %esi, %ecx")
  (restore-registers)
  (emit "  addi $sp, $sp, 36")
  (emit "  li   $v0, 17  # exit")
  (emit "  syscall             ")
  (emit-labels (all-conversions expr) emit-scheme-entry))

;;; test-program

(define (emit-test-library)
  (define (emit-library-primitive prim-name)
    (let ([labels (lib-primitive-code prim-name)])
      ;(emit-labels labels (lambda (expr env)
      ;  ((emit-code env #t) (make-code '() '() expr) (primitive-alloc prim-name))))
      (let ([label (primitive-label prim-name)])
        (emit "~s:      " label)
        (emit "  jr  $ra"))))
  (define (iterate libs)
    (if (null? libs) '()
        (begin (emit-library-primitive (car libs))
               (iterate (cddr libs)))))
  (emit ".text  ")
  (iterate lib-primitives))

(define (make-enumeration start end)
  (if (> start end) '()
      (if (= start end) (list start)
          (append (list start) (make-enumeration (+ start 1) end)))))

(define (emit-scheme-entry-i expr env index)
  (emit-function-header (string-append "L_scheme_entry_" index))
  (emit-tail-expr (- wordsize) env expr))

(define (emit-labels-i expr k index)
  (let* ([bindings (labels-bindings expr)]
         [labels (map lhs bindings)]
         [codes (map rhs bindings)]
         [env (make-initial-env '())])
    (for-each (emit-code env #f) codes labels)
    (k (labels-body expr) env index)))

(define (emit-test-result index)
  (emit-call (string-append "L_scheme_entry_" index))
  (emit "  li   $a0, 12")
  (emit "  li   $v0, 9")
  (emit "  syscall")
  (emit "  move $a0, $v0")
  (emit "  sw   $s1, 0($a0)")
  (emit "  sw   $s2, 4($a0)")
  (emit "  sw   $s3, 8($a0)")
  (emit-call "print_sexp")
  (emit "  li   $a0, '\\n'")
  (emit "  li   $v0, 11")
  (emit "  syscall"))

(define (emit-test-program expr-list testname)
  (define expr-indexes (make-enumeration 1 (length expr-list)))
  (define expr-name-indexes (map (lambda (i) (string-append testname "_" (number->string i))) expr-indexes))
  (emit-function-header (string-append "main_" testname))
  (emit "  addi $sp, $sp, -36")
  (backup-registers)
  ;(emit "  mov %ecx, %esi")
  ;(emit "  mov 12(%esp), %ebp")
  ;(emit "  mov 8(%esp), %esp")
  ;(emit "  mov $0, %edi")
  (map (lambda (i) (emit-test-result i)) expr-name-indexes)
  ;(emit "  mov %esi, %ecx")
  (restore-registers)
  (emit "  addi $sp, $sp, 36")
  (emit "  li   $v0, 17  # exit")
  (emit "  syscall             ")
  (map (lambda (e i) (emit-labels-i (all-conversions e) emit-scheme-entry-i i)) expr-list expr-name-indexes))

